home *** CD-ROM | disk | FTP | other *** search
/ SunSoft Catalyst CDWARE 1996 May to August / Catalyst CDWARE 1996 May to August.iso / .products / .bin / httpd / Solaris_1 / gen.pl < prev    next >
Perl Script  |  1996-02-29  |  8KB  |  292 lines
  1. #!./perl
  2. # ------------------------------------------------------------
  3. # generic_mailer2.pl, by phil hooper (pjh@netcom.com)
  4. #
  5. #####################################################################
  6. #
  7. # Copyright & Disclaimer
  8. # Original bits copyright Creative Dynamics, Inc, oct 1994
  9. # Permission to distribute, use, modify, ridicule granted
  10. # provided the Copyright and Disclaimer stays intact.
  11. #
  12. # This code is provided as-is, with no guarantee that it will
  13. # do anything (or for that matter, there is no guarantee that
  14. # it WON'T do anything, either).
  15. #
  16. #####################################################################
  17. #
  18. # unabashedly swiping code from Reuven M. Lerner and
  19. # and James tappin (see below)...after all, james burke
  20. # says nothing is ever invented, just assembled from bits...
  21. # all this thing does is mail the contents of a form
  22. # to the address specified in the 'mailto' widget
  23. # of the form.  the widget names/values are dumped one per line into
  24. # the email in the order they are specified in the form
  25. # definition.  widget names and types are irrelevant except
  26. # (of course) for the special cases:
  27. #
  28. # 1] the mailto widget specifies the mail address
  29. #
  30. #    e.g. <INPUT NAME="mailto" TYPE="hidden" VALUE="pjh@netcom.com">
  31. #
  32. # 2]  any time a widget named "space" is encountered, a blank
  33. #    line is inserted in the email instead of the value
  34. #    for the field.
  35. #
  36. #    e.g.  <INPUT NAME="space" TYPE="hidden" VALUE="space">
  37. #
  38. # 3] the request widget is used as the mail subject (sorry
  39. #    about 'request'...it was historical).
  40. #
  41. #    e.g. <INPUT NAME="request" TYPE="hidden" VALUE="spam order request">
  42. #
  43. # 4] the thanks_url widget can be used to replace the generic thank
  44. #    you page with a url you specify
  45. #
  46. #     e.g. <INPUT NAME="thanks_url" TYPE="hidden" VALUE="/stuff/thanks.html">
  47. #
  48. # 5] REQUIRED keywords can be added to the widgets NAME to indicate
  49. #    a value must be provided.
  50. #    if the user did not enter anything into that widget,
  51. #    then the form is not mailed and a page is displayed telling the
  52. #    user which fields require values (by NAME, so you want the widget
  53. #    name to be something obvious...the REQUIRED part is stripped off)
  54. #    
  55. #    e.g. Your Name : <INPUT NAME="REQUIRED Your Name">
  56. #         <BR>
  57. #         Your Email: <INPUT NAME="REQUIRED Your Email">
  58. # ---------------------------------------------------------------
  59. # credits
  60. # ---------------------------------------------------------------
  61. # Form-mail.pl, by Reuven M. Lerner (reuven@the-tech.mit.edu).
  62. # This is a rewrite of a program that was trashed by our power
  63. # surge in the middle of February 1994.
  64. # ---------------------------------------------------------------
  65. # The CGI_HANDLERS deal with basic CGI POST or GET method request
  66. # elements such as those delivered by an HTTPD form, i.e. a url
  67. # encoded line of "=" separated key=value pairs separated by &'s
  68.  
  69. # Routines:
  70. # get_request:    reads the request and returns both the raw and
  71. #               processed version.
  72. # url_decode:    URL decodes a string or array of strings
  73. # html_header:    Transmits a HTML header back to the caller
  74. # html_trailer: Transmits a HTML trailer back to the caller
  75.  
  76. # Author:
  77. #     James Tappin: sjt@xun8.sr.bham.ac.uk
  78. #    School of Physics & Space Research University of Birmingham
  79. #    Feb 1993.        
  80.  
  81. # Copyright & Disclaimer.
  82. #    This set of routines may be freely distributed, modified and
  83. #    used, provided this copyright & disclaimer remains intact.
  84. #    This package is used at your own risk, if it does what you
  85. #    want, good; if it doesn't, modify it or use something else--but
  86. #    don't blame me. Support level = negligable (i.e. mail bugs but
  87. #    not requests for extensions)
  88.  
  89. # Usage:
  90. #    &get_request;    will get the request and decode it into an
  91. #             indexed array %rqpairs, the raw request is in
  92. #             $request
  93. #
  94. #    ... = &url_decode(LIST); will return a URL decoded version of
  95. #                     the contents of LIST
  96. #
  97.  
  98. sub get_request {
  99.  
  100.     # Subroutine get_request reads the POST or GET form request from STDIN
  101.     # into the variable  $request, and then splits it into its
  102.     # name=value pairs in the associative array %rqpairs.
  103.     # The number of bytes is given in the environment variable
  104.     # CONTENT_LENGTH which is automatically set by the request generator.
  105.  
  106.     # Encoded HEX values and spaces are decoded in the values at this
  107.     # stage.
  108.  
  109.     # $request will contain the RAW request. N.B. spaces and other
  110.     # special characters are not handler in the name field.
  111.  
  112.     if ($ENV{'REQUEST_METHOD'} eq "POST") {
  113.     read(STDIN, $request, $ENV{'CONTENT_LENGTH'});
  114.     } elsif ($ENV{'REQUEST_METHOD'} eq "GET" ) {
  115.     $request = $ENV{'QUERY_STRING'};
  116.     }
  117.  
  118.  
  119.     @names = &url_decode(split(/[&=]/, $request));
  120.     %rqpairs = @names;
  121.  
  122. }
  123.  
  124. sub url_decode {
  125.  
  126. #    Decode a URL encoded string or array of strings 
  127. #        + -> space
  128. #        %xx -> character xx
  129.  
  130.  
  131.     foreach (@_) {
  132.     tr/+/ /;
  133.     s/%(..)/pack("c",hex($1))/ge;
  134.     }
  135.     @_;
  136. }
  137.  
  138. sub html_header {
  139.  
  140.     # Subroutine html_header sends to Standard Output the necessary
  141.     # material to form an HHTML header for the document to be
  142.     # returned, the single argument is the TITLE field.
  143.  
  144.     local($title) = @_;
  145.  
  146.     print "Content-type: text/html\n\n";
  147.     print "<html><head>\n";
  148.     print "<title>$title</title>\n";
  149.     print "</head>\n<body>\n";
  150. }
  151.  
  152. sub html_trailer {
  153.  
  154.     # subroutine html_trailer sends the trailing material to the HTML
  155.     # on STDOUT.
  156.  
  157.     local($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst)
  158.     = gmtime;
  159.  
  160.     local($mname) = ("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul",
  161.              "Aug", "Sep", "Oct", "Nov", "Dec")[$mon];
  162.     local($dname) = ("Sun", "Mon", "Tue", "Wed", "Thu", "Fri",
  163.              "Sat")[$wday]; 
  164.  
  165.     print "<p>\nGenerated by: <var>$0</var><br>\n";
  166.     print "Date: $hour:$min:$sec UT on $dname $mday $mname $year.<p>\n";
  167.     print "</body></html>\n";
  168. }
  169.  
  170. #
  171. # --------- Everything above here is generic ---------
  172. #
  173.  
  174. #
  175. # Define fairly-constants
  176. #
  177.  
  178. $mailprog = '/usr/ucb/mail';
  179.  
  180. #
  181. # Get the input, output header
  182. #
  183.  
  184. &get_request;
  185.  
  186.  
  187. #
  188. # make sure nobody tries to execute a subshell
  189. #
  190.  
  191. $rqpairs{'mailto'} =~ s/~!/ ~!/g;
  192.  
  193. #
  194. # check for REQUIRED keyword.  Set flag if value is required
  195. # but not provided, then put up a page and forget about sending
  196. # mail
  197. #
  198.  
  199. @check_reqs = @names;
  200. for $i (0..$#check_reqs){
  201.     $name = shift(@check_reqs);
  202.     $value = shift(@check_reqs);
  203.  
  204.     if ($name =~ /REQUIRED/) {
  205.         if ($value eq "") {
  206.             $bad = $name;
  207.             $bad =~ s/\s*REQUIRED\s*//;
  208.         push(@missing, $bad);
  209.     }
  210.     }
  211. }
  212.  
  213. if ($#missing >= 0) {
  214.     &html_header('Generic Mailer (by pjh@netcom.com)');
  215.     print "<H1>Missing Required Information</H1>\n";
  216.     print "<HR>\n";
  217.     print "<H3>Please provide values for the following:</H3>\n";
  218.     print "<UL>\n";
  219.     for $i (0..$#missing) {
  220.     $field = shift(@missing);
  221.     print "<LI> $field\n";
  222.     }
  223.     print "</UL>\n";
  224.     print "<HR>\n";
  225.     print "<H3>Go back and try again</H3>\n";
  226.  
  227.     &html_trailer;
  228.     exit 0;
  229. }
  230.  
  231. #
  232. # Now send mail to $rqpairs{'mailto'};
  233. #
  234.  
  235. open (MAIL, "|$mailprog -s \"$rqpairs{'request'}\" $rqpairs{'mailto'}") || die "Can't open $mailprog!\n";
  236.  
  237. print MAIL  "------------------------------------------------------------\n\n";
  238.  
  239. for $i (0..$#names){
  240.  
  241.     $name = shift(@names);
  242.     $value = shift(@names);
  243.  
  244.     $i++;
  245.  
  246.     if (($name ne "") && ($name ne 'mailto') && ($name ne 'thanks_url')) { 
  247.  
  248.     if ($name ne "space") {
  249.  
  250. #
  251. # be a little tidier if the $value has an embedded newline, print the
  252. # whole thing starting on a seperate line.
  253. #
  254.         $name =~ s/\s*REQUIRED\s*//;
  255.  
  256.             if ($value =~ /\n/) {
  257.         print MAIL "[$name]: (below)\n$value\n";
  258.         } else {
  259.         print MAIL "[$name]: $value\n";
  260.         }
  261.     } else {
  262.         print MAIL "\n";
  263.     }
  264.     }
  265. }
  266.  
  267. print MAIL "\n------------------------------------------------------------\n\n";
  268. print MAIL "Remote host: $ENV{'REMOTE_HOST'}\n";
  269. print MAIL "Remote IP address: $ENV{'REMOTE_ADDR'}\n";
  270. close (MAIL);
  271.  
  272. #
  273. # if they haven't provided a thank-you url, then print the
  274. # default thank you page.  if they have provided an url ,then
  275. # issue a redirect
  276. #
  277.  
  278. if ($rqpairs{'thanks_url'} eq "") {
  279.    &html_header('Generic Mailer (by pjh@netcom.com)');
  280.    print "<H1>Thank You!</H1>\n";
  281.    print "<HR>";
  282.    print "Your mail has been sent to <b>[$rqpairs{'mailto'}] </b>";
  283.    &html_trailer;
  284. } else {
  285.    print "Location: $rqpairs{'thanks_url'}\n\n";
  286. }
  287.  
  288.  
  289.  
  290.  
  291.  
  292.